{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleInstances          #-}

module Demo01 where

import WumpusExpr.Alpha
import WumpusExpr.Assoc
import WumpusExpr.Beta
import WumpusExpr.ConstFold
import WumpusExpr.ElimLet
import WumpusExpr.FreshMon
import WumpusExpr.Interp
import qualified WumpusExpr.JavaScript as JS
import qualified WumpusExpr.KNormal as K
import qualified WumpusExpr.PostScript as PS
import WumpusExpr.Radian
import WumpusExpr.Syntax
import WumpusExpr.TopLevel
import WumpusExpr.Types
import WumpusExpr.VarId

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Control.Applicative
import Control.Monad


--
-- Compile code will go in a library soon...
--
compile :: Program -> Either ErrMsg JS.Program
compile prog = runMon $ (JS.program <=< optimize <=< alpha <=< K.knormal) prog

optimize :: K.Program -> Mon K.Program
optimize = repeatM 3 optimizeSteps

optimizeSteps :: K.Program -> Mon K.Program
optimizeSteps = elimLet <=< constFold <=< assoc <=< beta


repeatM :: Monad m => Int -> (a -> m a) -> a -> m a
repeatM count mf = go count
  where
    go i a | i <= 0    = return a
           | otherwise = mf a >>= go (i-1)


interpret :: Program -> Either ErrMsg (Point,Point)
interpret prog = either Left interpretK $  runMon (steps prog)
  where
    steps = optimize <=< alpha <=< K.knormal


---

expr01 :: Expr
expr01 =     Cmd (Scale (Float 0.5) (Float 0.5))
         :>> Cmd (LineTo (Float 100.0) (Float 100.0))
         :>> Cmd Fill

wexpr01 :: WM ()
wexpr01 = scale 0.5 0.5 >>> lineto 100.0 100.0 >>> fill




prog01 :: Program
prog01 = Program maindef []
  where
    maindef = defFun0 "main" wexpr01


demo01 = either text JS.ppProgram $ compile prog01


demo01a = interpret prog01




{-

-- Nicer if we could reflect on types...
--
makeFun3 :: forall r1 r2 r3 a. 
            (ReflectType r1, ReflectType r2, ReflectType r3, ReflectType a) 
         => String
         -> (WExpr r1 -> WExpr r2 -> WExpr r3 -> WExpr a)
         -> Fundef
makeFun3 name body = Fundef 
    { fun_name       = PrimId name funty
    , fun_args       = [arg1, arg2, arg3]
    , fun_body       = runW (body (bodyArg arg1) (bodyArg arg2) (bodyArg arg3))
    } 
  where
    bodyArg = WExpr . pure . Var
    ty1     = reflectType (undefined :: r1)
    ty2     = reflectType (undefined :: r2)
    ty3     = reflectType (undefined :: r3)
    funty   = TyFun [ty1,ty2,ty3] (reflectType (undefined :: a))
    arg1    = PrimId "arg1" ty1
    arg2    = PrimId "arg2" ty2
    arg3    = PrimId "arg3" ty3
-}


square_def :: Fundef
square_def = defFun3 "square" fun 
   where
     fun :: WFloat -> WFloat -> WFloat -> WM ()
     fun w x y =   moveto x y
               >>> lineto (x + w) y                  -- go right
               >>> lineto (x + w) (y + w)            -- go up
               >>> lineto x       (y + w)            -- go left 
               >>> closepath                         -- go down automatic


square :: WFloat -> WFloat -> WFloat -> WM ()
square = funApply3 square_def 




-- Note - normal application subsitutes the function body.
-- This implies we don't actually want function defs to be 
-- functions themselves.

mainexpr :: WM ()
mainexpr = square 10.0 0 0

prog01b :: Program
prog01b = Program maindef [square_def]
  where
    maindef = defFun0 "main" mainexpr

kcompile :: Program -> Either ErrMsg K.Program
kcompile prog = runMon $ (optimize <=< alpha <=< K.knormal) prog


demo01b = either text K.ppProgram $ kcompile prog01b


{-

% Font load
/FL   % SZ NAME FL
{
  /sz exch def
  /fname exch def
  fname findfont
  sz scalefont
  setfont
} bind def

14 /Courier FL



-}

compilePs prog = runMon $ (PS.program <=< optimize <=< alpha <=< K.knormal) prog


load_courier :: Expr
load_courier = App (Var $ PrimId "LF" ty) [ PsSymbol "Courier", Int 14]
  where
    ty = TyFun [] TyUnit

prog02 :: Program
prog02 = Program maindef []
  where
    maindef = Fundef (PrimId "main" TyUnit) [] load_courier


demo02 = either text PS.ppProgram $ compilePs prog02